Over 1,000 Windows 95 Programs/Over 1000 Windows 95 Programs (Microforum) (Disc 1).iso/0767/dwinsock.pas

Pascal/Delphi Source File | 1995-07-17 | 33KB | 1,242 lines

{--------------------------------------------------------------
    WinSock component for Borland Delphi.

    This was edited using hard tabs every 2nd position.
    Options/Environment/EditorOptions/TabStops = "3 5"

    (C) 1995 by Ulf S÷derberg, [e-mail]
              Marc Palmer,   [e-mail]
                            Keith Hawes,   [e-mail]

    -- History --
        V1.0        950404        US        First release.
        V1.1        950407        US        Corrected TServerSocket bug.
        V1.2        950410        US        Added Address property to server.
        V1.3        950420        MP        Added bitmaps to components,
                                                        added CloseDown procedure to server,
                                                        Added AfterDisconnect and BeforeDisconnect
                                                        properties. Stopped Server accepting
                                                        >MAXCONN connections.
                        950421        US        Replaced TClientEvent and TServerEvent
                                                        with TSocketEvent which passes a TSocket
                                                        reference instead of connection id.
                                                        Also changed TClientSocket.Open and
                                                        TServerSocket.Listen to take one more
                                                        argument which is of type TSocketClass.
                                                        The creation of FConn for TClientSocket
                                                        and FConns array for TServerSocket is
                                                        now done in the Open and Listen procedures
                                                        when you know what kind of socket you want.
                        950421        MP        Patched the whole mess together! Also moved
                                                        the common properties (On from Client+server into
                                                        the TSockCtrl base.
                        950425        MP        Numerous changes to make Info notifications
                                                        work better and added a few new ones.
                                                        Introduced timeout handling. Set the TimeOut
                                                        property of the socket classes at design time
                                                        to set how many seconds it will take before a
                                                        timeout is declared. The OnTimeOut event is
                                                        called when this happends. In the handler you
                                                        should call Close. I'm not sure about Server
                                                        handling yet.
                                                        Replaced TServerSocket.FConns array with a
                                                        TSocketList (derived from TList). Incoming
                                                        connections are no longer limited by MAXCONN.
                                                        There is a design-time MaxConnections property
                                                        for limiting incoming connections.
                                                        Added TClientSocket.Options and
                                                        TServerSocket.ClientOptions properties. These
                                                        determine the mask used for the WSAAsyncSelect
                                                        calls to the corresponding sockets.
                        950509      US      TSockCtrl now inherits from TComponent.
                                                        TSockets are deleted from server.FConns on
                                                        close.
                        950711        US        Corrected bug in TSocket.RemoteHost as pointed
                                                        out by Keith Hawes.
                        950712        KH    * Correct nl not being set bugs in several methods
                                                    * moved LookupName and LookupService from TSocket
                                                        to TSockCtrl since they do not need a connected
                                                        socket to function.  This allows the lookup of
                                                        socket and service information before a
                                                        connection is made. Changed Params from Var to
                                                        const.
                                                    * Added LookupNameStr to return the address as a
                                                        string.
                                                    * Fixed bug in LocateService.
                        950713         KH    * Fixed Bug in TServerSocket.CBSockClose.  Need to
                                                        stop the search after finding and removing the
                                                        matching socket.  The loop stop value is set
                                                        only the first time in the loop and deleting an
                                                        item changes the count and a GFP will result.
                                                    * If all items are needed to be checked for
                                                        deletion use a while loop and don't inc(i) if
                                                        a delete takes place to avoide skipping any
                                                        entries.
                        950714        KH    * Moved RecvText and SendText to TSocket's Private
                                                        section.

    Parts of this code was inspired by WINSOCK.PAS by Marc B. Manza.
---------------------------------------------------------------}

unit DWinSock;

interface

uses
    SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
    Forms, Dialogs, Buttons;

const
    CM_SOCKMSG    = WM_USER+1;

{$I winsock.inc }
{$I winsock.if }

type
    { DWinSock exception type }
    ESockError = class(Exception);

  TAsyncOptionsType = ( csoRead, csoWrite, csoOOB );
  TAsyncOptions = set of TAsyncOptionsType;

  TSockCtrl = class;    { Forward declaration }

    { TSocket -- socket api wrapper class. }
    TSocket = class(TObject)
  private
        function RecvText : string;
    procedure SendText(const s : string);
    public
        FParent            : TSockCtrl;        { socket owner }
        FSocket            : TSock;                { socket id }
        FAddr                : sockaddr_in;    { host address }
        FConnected    : boolean;
        FBytesSent    : integer;            { bytes sent by last SendBuf call }

        constructor Create(AParent : TSockCtrl); virtual;
        destructor Destroy;

        procedure FillSocket(var name, addr, service : string; var port : u_short);

        function LocalAddress : string;
        function LocalPort : integer;

        function RemoteHost : string;
        function RemoteAddress : string;
        function RemotePort : integer;

        procedure SetOptions; virtual;

        procedure Listen(var name, addr, service : string; port : u_short;
                            nqlen : integer);
        procedure Open(var name, addr, service : string; port : u_short;
                            opts : TAsyncOptions);
        procedure Close;

        function Send(var buf; cnt : integer) : integer;
        function Recv(var buf; cnt : integer) : integer;

        function InCount : integer;

        property BytesSent : integer read FBytesSent;
        property Text : string read RecvText write SendText;
    end;

    TSocketClass = class of TSocket;

    TSocketList = class (TList)
    protected
        function GetSocket( Index : Integer ) : TSocket;
    public
        property Sockets[ Index : Integer ] : TSocket read GetSocket;
    end;

    { Socket info codes }
    { MP 20/04/95 added siInactive - not used yet - obsolete? }
    {    25/04/95 added siConnected, siClosed, siTimedOut }
    TSockInfo = (  siInactive, siLookUp, siConnect, siConnected, siListen,
                                 siRecv, siSend, siClosed, siTimedOut);

    {    Define notification events for socket controls. }
    TSockInfoEvent = procedure (Sender : TObject; icode : TSockInfo) of object;
    TSocketEvent = procedure (Sender : TObject; Socket : TSocket) of object;

    {    TSockCtrl -- socket control component base class. }
    TSockCtrl = class(TComponent)
    private
        { US 950509 }
        FHWnd                    : HWnd;

        {    Event handler references }
        FOnInfo                : TSockInfoEvent;
        { MP 21/4/95 Moved from TClient+TSocket and 2 new properties added }
        FOnDisconnect    : TSocketEvent;
        FOnRead                : TSocketEvent;
        FOnWrite            : TSocketEvent;
        FOnTimeOut        : TSocketEvent;

        { MP 25/4/95 New fields to handle timeout + timer event chains }
        FTimerChainParent, FTimerChainChild : TSockCtrl;
        FTimeOutRemaining   :  Integer;
        FTimeOutActive      :  Boolean;

        { Design time connection info }
        FHost                    : string;
        FAddress            : string;
        FService            : string;
        FPort                    : u_short;

        FConn                    : TSocket;                { Run time connection info }
        FClass                : TSocketClass;        { class of socket beeing used }
        FTimeOut            : integer;                { timeout length in seconds }

        { Access functions }
        procedure SetService(const s : string);
        procedure SetHost(const n : string);
        procedure SetAddress(const a : string);
        procedure SetPort(p : u_short);
{ MP 25/4/95 }
        procedure SetTimeOut( p : Integer);

        { Returns the WinSock.DLL description }
        function GetDescription : string;

    protected
        { Protected declarations }
        constructor Create(AOwner : TComponent); override;
        destructor Destroy; override;
        procedure CBSockClose(ASocket : TSocket); virtual;

        { US 950509 }
        procedure WndProc(var Message : TMessage);
        procedure OnSockMsg(var Message : TMessage); virtual; abstract;

        { MP 25/4/95 }
        procedure TimerEvent( Sender : TObject);
        procedure UseTimer;
        procedure ReleaseTimer;

        { MP 25/4/95  New properties }
        property OnTimeOut : TSocketEvent read FOnTimeOut write FOnTimeOut;
        property TimeOut : Integer read FTimeOut write SetTimeOut;

    public
        { Public declarations }
        procedure Info(icode : TSockInfo);
        function LocalHost : string;
        function Reverse(var a : string) : string;

        {KH 950712}
        function LookupName(const name : string) : in_addr;
        function LookupNameStr(const name : string) : string;
        function LookupService(const service : string) : u_short;


        property Handle : HWND read FHWnd;    { US 950509 }
        property Conn : TSocket read FConn;
        property Description : string read GetDescription;

    published
        { Published declarations }
        property Address : string read FAddress write SetAddress;
        property Port : u_short read FPort write SetPort;
        property Service : string read FService write SetService;
        property OnInfo : TSockInfoEvent read FOnInfo write FOnInfo;

{ MP 21/4/95  Moved these props from client+server to TSockctrl }
        property OnDisconnect : TSocketEvent read FOnDisconnect write FOnDisconnect;
        property OnRead : TSocketEvent read FOnRead write FOnRead;
        property OnWrite : TSocketEvent read FOnWrite write FOnWrite;
    end;

    { Definition of the TClientSocket component class }
    TClientSocket = class(TSockCtrl)
    private
        FOnConnect    : TSocketEvent;
        FOptions    : TAsyncOptions;
    protected
        { Protected declarations }
        procedure OnSockMsg(var Message : TMessage); override;
        procedure CBSockClose(ASocket : TSocket); override;

    public
        { Public declarations }
        procedure Open(ASocketClass : TSocketClass);
        procedure Close;
        function Connected : boolean;

    published
        { Published declarations }
         constructor Create(AOwner : TComponent); override;
        destructor Destroy; override;

        property Host : string read FHost write SetHost;
        property Options : TAsyncOptions read FOptions write FOptions
                                            default [csoRead, csoWrite];
        property OnConnect : TSocketEvent read FOnConnect write FOnConnect;
        property OnTimeOut;
        property TimeOut;
    end;

    { Definition of the TServerSocket component class }
    TServerSocket = class(TSockCtrl)
    private
        { Event handler references }
        FOnAccept                : TSocketEvent;

        FMaxConns                : Integer;
        FConns                    : TSocketList;
        FSocketClass        : TSocketClass;

        { MP 20/4/95 }
        FOptions                : TAsyncOptions;

        function GetClient(cid : integer) : TSocket;
        function GetClientCount : integer;

        function DoAccept : integer;

    protected
        { Protected declarations }
        procedure OnSockMsg(var Message : TMessage); override;
    procedure CBSockClose(ASocket : TSocket); override;

    public
        { Public declarations }
         constructor Create(AOwner : TComponent); override;
        destructor Destroy; override;

        procedure Listen(nqlen : integer; ASocketClass : TSocketClass);
        procedure Close;

        { MP 20/04/95 added CloseDown declaration. Used CloseDown to avoid
        confusion    with winsock's Shutdown }
        procedure CloseDown; { close server and all connections }
        { Return client socket }
        property Client[cid : integer] : TSocket read GetClient; default;
        property ClientCount : Integer read GetClientCount;

    published
        { Published declarations }
        property OnAccept : TSocketEvent read FOnAccept write FOnAccept;
        { MP 25/4/95 New property }
        property MaxConnections : Integer read FMaxConns write FMaxConns default 16;
        property ClientOptions : TAsyncOptions read FOptions write FOptions
                                                            default [csoRead, csoWrite];
    end;

procedure Register;

implementation

uses ExtCtrls;

{ -- $R DWINSOCK}
const
  { MP 20/04/95 Constant used for drawing component at design time }
  dwsBtnBorderWidth = 2;
  TimerUserCount : Integer = 0;
    TimerChainRoot : TSockCtrl = nil;

var
    ExitSave     : Pointer;
    bStarted  : boolean;
    nUsers    : integer;
    nWSErr    : integer;
    myVerReqd : word;
  myWSAData : WSADATA;
  Timer     : TTimer;

{$I ERROR.INC}

function MakeAsyncMask( Options : TAsyncOptions) : Longint;
begin
  Result := 0;

  if csoRead in Options then
      Result := FD_READ;

  if csoWrite in Options then
      Result := Result or FD_WRITE;

  if csoOOB in Options then
      Result := Result or FD_OOB;
end;

{ StartUp -- See if a Windows Socket DLL is present on the system. }
procedure StartUp;
begin
    if bStarted then exit;
  nUsers := 0;
    myVerReqd:=$0101;
    nWSErr := WSAStartup(myVerReqd,@myWSAData);
    if nWSErr = 0 then
        bStarted := True
    else
        raise ESockError.Create('Can''t startup WinSock');
end;

{ CleanUp -- Tell Windows Socket DLL we don't need its services any longer. }
procedure CleanUp; far;
begin
    ExitProc := ExitSave;
{ MP 25/4/95 Free timer }
  Timer.Free;
    if bStarted then
  begin
     nWSErr := WSACleanup;
     bStarted := false;
    end;
end;

function TSocketList.GetSocket( Index : Integer ) : TSocket;
begin
  Result := Items[Index];
end;

{--------------------------------------------------------------
    TSocket implementation
 --------------------------------------------------------------}

constructor TSocket.Create(AParent : TSockCtrl);
begin
    inherited Create;
  FParent := AParent;
    FSocket := INVALID_SOCKET;
    FAddr.sin_family := PF_INET;
    FAddr.sin_addr.s_addr := INADDR_ANY;
  FAddr.sin_port := 0;
    FConnected := false;
    FBytesSent := 0;
end;

destructor TSocket.Destroy;
begin
    if FSocket <> INVALID_SOCKET  then
        CloseSocket(FSocket);
    inherited Destroy;
end;

{ LocalAddress -- get local address }
function TSocket.LocalAddress : string;
var
    sa : sockaddr_in;
    nl : integer;
begin
    Result := '';
    if FSocket = INVALID_SOCKET then exit;
 nl := SizeOf(sa);
    if getsockname(FSocket, PSockaddr(@sa), @nl) = 0 then
        Result := StrPas(inet_ntoa(sa.sin_addr));
end;

{ LocalPort -- get local port number }
function TSocket.LocalPort : integer;
var
    sa : sockaddr_in;
    nl : integer;
begin
    Result := 0;
    if FSocket = INVALID_SOCKET then exit;
 nl := SizeOf(sa);
    if getsockname(FSocket, PSockaddr(@sa), @nl) = 0 then
        Result := ntohs(sa.sin_port);
end;

{ RemoteHost -- get name of connected remote host }
function TSocket.RemoteHost : string;
var
    sa    : sockaddr_in;
  nl    : integer;
    phe : PHostEnt;
begin
    Result := '';
    if not FConnected then exit;
    nl := sizeof(sa);
    { Get connection address info }
    getpeername(FSocket, PSockaddr(@sa), @nl);
    FAddr := sa;
    { Do a reverse lookup to get the host name }
    phe := gethostbyaddr(PChar(@FAddr.sin_addr.s_addr), 4, PF_INET);
    if phe <> nil then
        Result := StrPas(phe^.h_name);
end;

{ RemoteAddress -- get address of connected remote host }
function TSocket.RemoteAddress : string;
var
    sa : sockaddr_in;
    nl : integer;
begin
    Result := '?';
    if (FSocket = INVALID_SOCKET) or (not FConnected) then exit;
    nl := SizeOf(sa);
    if getpeername(FSocket, PSockaddr(@sa), @nl) = 0 then
        Result := StrPas(inet_ntoa(sa.sin_addr));
end;

{ RemotePort -- get remote port number }
function TSocket.RemotePort : integer;
var
    sa : sockaddr_in;
    nl : integer;
begin
    Result := 0;
    if (FSocket = INVALID_SOCKET) or (not FConnected) then exit;
    nl := SizeOf(sa);
    if getpeername(FSocket, PSockaddr(@sa), @nl) = 0 then
        Result := ntohs(sa.sin_port)
    else
        Result := 0;
end;

{ FillSocket -- fill in address and port fields in socket struct }
procedure TSocket.FillSocket(var name, addr, service : string;
                    var port : u_short);
var
    s    : array [1..32] of char;
begin
    { Fill in address field }
    if name <> '' then                        { Host name given }
        begin
            FAddr.sin_addr := FParent.LookupName(name);        {KH 950712}
         addr := StrPas(inet_ntoa(FAddr.sin_addr));
        end
    else if addr <> '' then                { IP address given }
        begin
            FAddr.sin_addr.s_addr := 0;
            if addr <> '0.0.0.0' then    { beware of Trumpet bug! }
                begin
                    StrPCopy(@s, addr);
                    FAddr.sin_addr.s_addr := inet_addr(@s);
                end;
        end
    else                                                    { Neither name or address given }
        raise ESockError.Create('No address specified');

    { Fill in port number field }
    if service <> '' then
        begin
            FAddr.sin_port := FParent.LookupService(service);  {KH 950712}
                port := FAddr.sin_port;
     end
  else
        FAddr.sin_port := htons(port);
end;

{ SetOptions -- set socket options }
procedure TSocket.SetOptions;
begin
end;

{ Listen -- wait for incoming connection. }
procedure TSocket.Listen(var name, addr, service : string; port : u_short; nqlen : integer);
var
    q, e    : integer;
begin
    if (not bStarted) then
      raise ESockError.Create('WINSOCK not started');

    FSocket := DWinsock.socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
    if FSocket = INVALID_SOCKET then
      raise ESockError.Create('Can''t create new socket');

  FillSocket(name, addr, service, port);

  SetOptions;

    if bind(FSocket, Psockaddr(@FAddr), SizeOf(FAddr)) <> 0 then
        begin
           e := WSAGetLastError;
            Close;
            raise ESockError.Create('Bind failed, '+Error(e));
        end;

    WSAAsyncSelect(FSocket, FParent.Handle, CM_SOCKMSG, FD_ACCEPT or FD_CLOSE);

    if DWinsock.listen(FSocket, q) <> 0 then
    begin
        e := WSAGetLastError;
        if FSocket <> INVALID_SOCKET then
            Close;
        raise ESockError.Create('Listen failed, '+Error(e));
    end else FParent.Info(siListen);
end;

{    Open a connection. }
procedure TSocket.Open(var name, addr, service : string; port : u_short;
                                                    opts : TAsyncOptions);
var
    e        : integer;
begin
    if (not bStarted) then
        raise ESockError.Create('WINSOCK not started');

    if FConnected then
        raise ESockError.Create('Can''t open an open socket');

    FSocket := DWinsock.socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
    if FSocket = INVALID_SOCKET then
        raise ESockError.Create('Can''t create new socket');

    FParent.Info(siLookUp);
    { MP 25/4/95 }
  FParent.UseTimer; { start timeout check }

  FillSocket(name, addr, service, port);
    { MP 25/4/95 }
  FParent.ReleaseTimer;

  SetOptions;

    WSAAsyncSelect(FSocket, FParent.Handle, CM_SOCKMSG, MakeAsyncMask(opts) or
                                FD_CONNECT or FD_CLOSE);

    { MP 25/4/95 }
    FParent.UseTimer; { start timeout check }
    FParent.Info(siConnect);
    if connect(FSocket, Psockaddr(@FAddr), SizeOf(FAddr)) <> 0 then
        if WSAGetLastError <> WSAEWOULDBLOCK then
            begin
                e := WSAGetLastError;
                if FSocket <> INVALID_SOCKET then
                    Close;
                raise ESockError.Create('Open failed: ' + Error(e));
            end;
end;

procedure TSocket.Close;
begin
    if (not bStarted) or (FSocket = INVALID_SOCKET) then exit;
    FConnected := false;
    closesocket(FSocket);
    FSocket := INVALID_SOCKET;
    FBytesSent := 0;
  FParent.CBSockClose(self);
end;

function TSocket.RecvText : string;
var
  n : integer;
begin
    n := Recv(PChar(@Result[1])^, 255);
  Result[0] := char(n);
end;

procedure TSocket.SendText(const s : string);
begin
    FBytesSent := Send(PChar(@s[1])^, Length(s));
end;

{    Send contents of passed buffer. }
function TSocket.Send(var buf; cnt : integer) : integer;
var
    n : integer;
begin
    Result := 0;
    if (FSocket = INVALID_SOCKET) or (not FConnected) then exit;
    n := DWinsock.send(FSocket, @buf, cnt, 0);
    if n > 0 then
        Result := n
    else if (n = SOCKET_ERROR) and (WSAGetLastError <> WSAEWOULDBLOCK) then
        begin
            Close;
        raise ESockError.Create('Send error');
     end;
end;

{    Request that passed buffer be filled with received data. }
function TSocket.Recv(var buf; cnt : integer) : integer;
var
    n : integer;
begin
    Result := 0;

    if (FSocket = INVALID_SOCKET) or (not FConnected) then
      raise ESockError.Create('Socket not open');

    n := DWinsock.recv(FSocket, @buf, cnt, 0);
    if n > 0 then
        Result := n
  else if (n = SOCKET_ERROR) and (WSAGetLastError <> WSAEWOULDBLOCK) then
      begin
            Close;
            raise ESockError.Create('Recv error');
     end;
end;

{ InCount -- Get # of bytes in receive buffer }
function TSocket.InCount : integer;
const
    FIONREAD = $40000000 or ((longint(4)) shl 16) or (ord('f') shl 8) or 127;
var
    n        : longint;
begin
    Result := 0;
    if ioctlsocket(FSocket, FIONREAD, n) <> 0 then
      raise ESockError.Create('ioctlsocket error: ' + error(WSAGetLastError));
  Result := n and $ffff;
end;

{--------------------------------------------------------------
    TSockCtrl implementation
 --------------------------------------------------------------}

{ Create -- initalization }
constructor TSockCtrl.Create(AOwner : TComponent);
begin
    inherited Create(AOwner);
    { US 950509 }
  FHWnd := AllocateHWnd(WndProc);

    { The control should be visible at design time only.
      At run time, check if the WINSOCK has been started. }
    if not (csDesigning in ComponentState) then
        StartUp;

  FHost := '';
  FAddress := '0.0.0.0';

  FService := '';
  FPort := 0;

    inc(nUsers);
end;

{ Destroy -- destruction }
destructor TSockCtrl.Destroy;
var
    res : integer;
begin
  ReleaseTimer;
  FConn.Free;
    Dec(nUsers);
  if nUsers <= 0 then
        CleanUp;
    { US 950509 }
    DeallocateHWnd(FHwnd);
    inherited Destroy;
end;

{ US 950509: WndProc -- trap socket messages. }
procedure TSockCtrl.WndProc(var Message : TMessage);
begin
  with Message do
        case Msg of
            CM_SOCKMSG : OnSockMsg(Message);
      else
      DefWindowProc(FHWnd, Msg, wParam, lParam);
      end;
end;

procedure TSockCtrl.CBSockClose(ASocket : TSocket);
begin
end;

{ MP 25/4/95  Handle the time out timer events
              This gets a bit tricky, because we don't want to keep
                            wasting CPU time if we have already timed out, so we release
              the timer if we time out. This can only be done once the
              other components in the chain have been called.
}
procedure TSockCtrl.TimerEvent( Sender : TObject );
begin
    if Assigned(FTimerChainChild) then
      FTimerChainChild.TimerEvent(Sender);
    if FTimeOutRemaining > 0 then
      Dec(FTimeOutRemaining);
    if FTimeOutRemaining = 0 then
        begin
            ReleaseTimer; { do this NOW in case event handler takes too long! }
            Info(siTimedOut);
            { MP This should actually pass the actual socket in the case of a server }
            if Assigned(FOnTimeOut) then
          OnTimeOut(Self, Conn);
        end;
end;

{ Info -- call the OnInfo event handler if any. }
procedure TSockCtrl.Info(icode : TSockInfo);
begin
    if Assigned(FOnInfo) then
      FOnInfo(Self, icode);
end;

{ GetDescription -- return description of WinSock implementation }
function TSockCtrl.GetDescription : string;
begin
    Result := StrPas(myWSAdata.szDescription);
end;

{ LocalHost -- return name of local host }
function TSockCtrl.LocalHost : string;
var
    sh : array [0..255] of char;
begin
    if not bStarted then
        begin
            Result := '';
            Exit;
        end;
    if gethostname(sh, 255) = 0 then
        Result := StrPas(sh)
    else
        Result := '';
end;

{ Set host name }
procedure TSockCtrl.SetHost(const n : string);
begin
    FHost := n;
  FAddress := '';
end;

{ Set host address }
procedure TSockCtrl.SetAddress(const a : string);
begin
    FAddress := a;
  FHost := '';
end;

{ Set service name }
procedure TSockCtrl.SetService(const s : string);
begin
    FService := s;
  FPort := 0;
end;

{ Set port number }
procedure TSockCtrl.SetPort(p : u_short);
begin
    FPort := p;
  FService := '';
end;

{ MP 25/4/95 }
{ Set time out delay }
procedure TSockCtrl.SetTimeOut( p : Integer);
begin
  if p < 0 then p := 0; { trap negatives }
    FTimeOut := p;
end;

{ there is one global timer, and the different controls chain the calls
to the OnTimer event. }
procedure TSockCtrl.UseTimer;
begin
    if (csDesigning in ComponentState) then
      Exit;

  if (FTimeOut = 0) or (not Assigned(FOnTimeOut)) then exit;

    if not Assigned(Timer) then
        begin
            Timer := TTimer.Create(Self);
            Timer.Interval := 1000;
            Timer.Enabled := True;
        end;

    { Add ourselves to the top of the chain }
    FTimerChainChild := TimerChainRoot;
    FTimerChainParent := nil;
    TimerChainRoot := Self;
    Timer.OnTimer := TimerEvent;
    FTimeOutActive := True;
    FTimeOutRemaining := FTimeOut;
    Inc(TimerUserCount);
end;

procedure TSockCtrl.ReleaseTimer;
begin
    if (csDesigning in ComponentState) then Exit;

    { US 950502 + removed lots of if FTimeOutActive from other places }
    if not FTimeOutActive then Exit;

    { remove ourselves from the chain }
    if Assigned(FTimerChainParent) then
        { reinstate previous handler }
        FTimerChainParent.FTimerChainChild := FTimerChainChild
    else
        begin
            if Assigned( FTimerChainChild) then
          Timer.OnTimer := FTimerChainChild.TimerEvent
            else
          Timer.OnTimer := nil;
            TimerChainRoot := FTimerChainChild;
        end;

    if Assigned(FTimerChainChild) then
        FTimerChainChild.FTimerChainParent := FTimerChainParent;

    Dec(TimerUserCount);
    FTimeOutActive := False;
    if TimerUserCount = 0 then
        begin
            Timer.Enabled := False;
            Timer.Free;
            Timer := nil;
        end;
end;

{ Reverse -- try to do a reverse lookup }
function TSockCtrl.Reverse(var a : string) : string;
var
    phe    : PHostEnt;
    s        : array[0..31] of char;
    sa    : in_addr;
begin
    StrPCopy(s, a);
    sa.s_addr := inet_addr(s);
    if sa.s_addr = 0 then
        raise ESockError.Create('Can''t do reverse lookup on address 0.0.0.0');

    phe := gethostbyaddr(PChar(@sa.s_addr), 4, PF_INET);
    if phe <> nil then
        Result := StrPas(phe^.h_name)
    else
        raise ESockError.Create('Reverse lookup on ' + a + ' failed');
end;

{ LookupName -- try to look up host name }
function TSockCtrl.LookupName(const name : string) : in_addr;
var
  phe    : PHostEnt;
  pa    : PChar;
     sz    : array [1..64] of char;
  sa    : in_addr;
begin
    StrPCopy(@sz, name);
    phe := gethostbyname(@sz);
    if phe <> nil then
        begin
        { US 950518 fixed h_addr bug }
            pa := phe^.h_addr_list^;
            sa.S_un_b.s_b1:=pa[0];
            sa.S_un_b.s_b2:=pa[1];
            sa.S_un_b.s_b3:=pa[2];
            sa.S_un_b.s_b4:=pa[3];
     Result := sa;
   end
 else
      raise ESockError.Create('Can''t find host ' + name);
end;

function TSockCtrl.LookupNameStr(const name : string): string;
begin
  Result := StrPas(inet_ntoa(LookupName(name)));
end;

{ LookupService -- try to lookup service name }
function TSockCtrl.LookupService(const service : string) : u_short;
var
    ps    : PServEnt;
    proto    : array [1..32] of char;
    name : array [1..64] of char;
begin
    Result := 0;
    StrPCopy(@proto, 'tcp');
    StrPCopy(@name, service);
    ps := getservbyname(@name, @proto);
    if ps <> nil then
        Result := htons(ps^.s_port){ KH 950712 Changed from: Result := ps^.s_port }
    else
        raise ESockError.Create('Can''t find port for service ' + service);
end;

{--------------------------------------------------------------
    TClientSocket implementation.
 --------------------------------------------------------------}

constructor TClientSocket.Create(AOwner : TComponent);
begin
    inherited Create(AOwner);
  FOptions := [ csoRead, csoWrite ];
end;

destructor TClientSocket.Destroy;
begin
    inherited Destroy;
end;

procedure TClientSocket.CBSockClose(ASocket : TSocket);
begin
{    FConn.Free;
  FConn := nil;}
end;

procedure TClientSocket.Open(ASocketClass : TSocketClass);
begin
    if Connected then
        raise ESockError.Create('Already opened!');
    FConn.Free;
    FConn := ASocketClass.Create(self);
    FConn.Open(FHost, FAddress, FService, FPort, FOptions);
end;

procedure TClientSocket.Close;
begin
    { US 950502 }
    if FConn = nil then
      raise ESockError.Create('Not opened!');
     ReleaseTimer;
    FConn.Close;
end;

function TClientSocket.Connected : boolean;
begin
    Result := false;
    if FConn <> nil then
      Result := FConn.FConnected;
end;

{ OnSockMsg -- handle CM_SOCKMSG }
procedure TClientSocket.OnSockMsg(var Message : TMessage);
var
    sock : TSock;
    evt, err : word;
begin
    sock := TSock(Message.wParam);
    evt := WSAGetSelectEvent(Message.lParam);
    err := WSAGetSelectError(Message.lParam);

    case evt of
        FD_CONNECT:
            begin
                FConn.FConnected := true;
                { MP 25/4/95 }
           ReleaseTimer;
                { MP 950425 Let app know connection is made }
                Info(siConnected);
                if Assigned(FOnConnect) then
                    FOnConnect(self, FConn);
            end;

        FD_CLOSE:
            begin
                if FConn.FConnected then
                    begin
                        { US 950502 user must call xxx.Close method in OnDisconnect event }
                        if Assigned(FOnDisconnect) then
                            FOnDisconnect(Self, FConn);
                        { MP 20/4/95 }
               ReleaseTimer;
                        Info(siClosed);
                    end;
                end;

            FD_OOB: ;
            FD_READ:
                if Assigned(FOnRead) then
                    FOnRead(Self, FConn);

            FD_WRITE:
                if Assigned(FOnWrite) then
                    FOnWrite(Self, FConn);
        end;
    end;

{--------------------------------------------------------------
    TServerSocket functions
 --------------------------------------------------------------}

constructor TServerSocket.Create(AOwner : TComponent);
begin
    inherited Create( AOwner );
  FConn := TSocket.Create( Self );
  FConns := TSocketList.Create;
  FMaxConns := 16;
  FOptions := [ csoRead, csoWrite ];
end;

destructor TServerSocket.Destroy;
var
    i : integer;
begin
    for i := 0 to FConns.Count-1 do
        FConns.Sockets[i].Free;
  FConns.Free;
    inherited Destroy;
end;

function TServerSocket.GetClient(cid : integer) : TSocket;
begin
    Result := FConns[cid];
end;

function TServerSocket.GetClientCount : integer;
begin
    Result := FConns.Count;
end;

procedure TServerSocket.Close;
begin
    { US 950502 }
    ReleaseTimer;
    FConn.Close;
end;

{ MP 20/04/95 CloseDown added. Closes all connection sockets and then closes
  the server socket. Useful for shutting down entire server without destroying
  the actual server object }
procedure TServerSocket.CloseDown;
var
    i : Integer;
begin
    for i := 0 to FConns.Count-1 do
      FConns.Sockets[i].Close;
    { MP 20/4/95 }
    FConn.Close;

    { US 950502 }
  ReleaseTimer;
end;

{ US 950427: CBSockClose }
procedure TServerSocket.CBSockClose(ASocket : TSocket);
var
    i        : integer;

begin
    if ASocket = FConn then Exit;  { Server's socket will NOT be in the list }
    for i := 0 to FConns.Count-1 do
        if FConns.Sockets[i].FSocket = ASocket.FSocket then
            begin
                FConns.Sockets[i].Free;
                FConns.Delete(i);
                FConns.Pack;  { ok, not particularly efficient }
                Break; { KH 950713 Why Keep going we just removed it }
            end;
end;

{ OnSockMsg -- handle CM_SOCKMSG from WINSOCK }
procedure TServerSocket.OnSockMsg(var Message : TMessage);
var
    sock    : TSock;
    evt    : word;
  err    : word;
    cid    : integer;

    procedure FindConn;
    var
        i : integer;
    begin
        cid := -1;
        for i := 0 to FConns.Count-1 do
            if FConns.Sockets[i].FSocket = sock then
                begin
                    cid := i;
                    Exit;
                end;
    end;

begin
    sock := TSock(Message.wParam);
    evt := WSAGetSelectEvent(Message.lParam);
    err := WSAGetSelectError(Message.lParam);

    case evt of
        FD_ACCEPT:
            begin
                cid := DoAccept;
                if Assigned(FOnAccept) and (cid >= 0) then
                    FOnAccept( Self, FConns[cid]);
            end;

        FD_CLOSE:
            begin
                FindConn;
                { MP 18/4/95 changed this from NOT FConns[ to FConns[
                  I think the logic was slightly erroneous }
                if FConns.Sockets[cid].FConnected then
                    begin
                        { US 950502 user must call xxx.Close method }
                        if Assigned(FOnDisconnect) then
                            FOnDisconnect(Self, FConns.Sockets[cid]);

                        { MP 25/4/95 }
               ReleaseTimer;
                        Info(siClosed);
                    end;
            end;

        FD_OOB: ;
        FD_READ:
            begin
                FindConn;
                if Assigned(FOnRead) then
                    FOnRead( Self, FConns[cid] );
            end;

        FD_WRITE:
            begin
                FindConn;
                if Assigned(FOnWrite) then
                    FOnWrite( Self, FConns[cid] );
            end;
    end;
end;

function TServerSocket.DoAccept : integer;
var
    ts       : TSocket;
    nl       : integer;
    cid   : integer;

    function NewConn : integer;
    begin
     Result := FConns.Add( FSocketClass.Create(Self) );
    end;

begin
    Result := -1;
{ MP 25/4/95 - Do not accept any more than FMaxConns connections.
  Should we do something to let the client know? Like accept and then
  close straight away ? }
  if FConns.Count >= FMaxConns then Exit;

    cid := NewConn;
    ts := FConns[cid];
    nl := sizeof(sockaddr_in);
    ts.FSocket := accept(FConn.FSocket, PSockaddr(@ts.FAddr), @nl);
    if ts.FSocket <> INVALID_SOCKET then
        begin
            WSAAsyncSelect(ts.FSocket, Handle, CM_SOCKMSG, MakeAsyncMask(FOptions) or
                                        FD_CLOSE);
            ts.FConnected := True;
            Result := cid;
        end;
end;

procedure TServerSocket.Listen(nqlen : integer; ASocketClass : TSocketClass);
var
    i    : integer;
begin
    FSocketClass := ASocketClass;
    FConn.Listen(FHost, FAddress, FService, FPort, nqlen);
end;

{    Register our components. }
procedure Register;
begin
    RegisterComponents('Samples', [TClientSocket]);
    RegisterComponents('Samples', [TServerSocket]);
end;

{$I winsock.imp }

{--------------------------------------------------------------
    Unit initialization code.
 --------------------------------------------------------------}

initialization
    bStarted := False;
    Timer := nil;
    ExitSave := ExitProc;
  ExitProc := @CleanUp;
end.